
sql.select <- function(query, envir = parent.frame( ), 
	what.to.parse = "sql.stmt.sequence", 
	fetch.tokenlist = FALSE, 
	escape.char = "`", closing.escape.char = escape.char ) {

	# sql.select, 2010-2011 by Dennis Toddenroth (at gmail: dtoddenroth) 
	# Query data.frames using SQL's SELECT-syntax within R.
	# 
	# This program is free software; you can redistribute it and/or
	# modify it under the terms of the GNU General Public License
	# as published by the Free Software Foundation; either version 2
	# of the License, or (at your option) any later version.
	# 
	# This program is distributed in the hope that it will be useful,
	# but WITHOUT ANY WARRANTY; without even the implied warranty of
	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
	# GNU General Public License for more details.
	# 
	# You should have received a copy of the GNU General Public License
	# along with this program; if not, write to the Free Software
	# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
	# 
	# see http://sqlselect.googlecode.com/ 

	keywords <- c("create", "temporary", "temp", "view", "table", "select", "from", "where", "group by", 
		"having", "order by", "union", "intersect", "natural join", "inner join", 
		"on", "using", "limit", "offset", "asc", "desc", "as", "distinct", 
		"cross join", "left join" ) 
	tokenset <- as.list(paste("^", gsub(" ", "\\\\s+", keywords ), sep="" ) )
	names(tokenset ) <- gsub(" ", "", keywords )

	tokenset <- c(tokenset, 
		ws = "^\\s+", 
		allcols = "^\\*", 
		integer.number = "^[0123456789]+", 
		bropen = "^\\(", 
		brclose = "^\\)", 
		semicolon = "^\\;", 
		comma = "^\\,", 
		comment = "(^\\-\\-[^\n]*\n)|(^\\-\\-[^\n]*$)", 
		ridentifier = "^[\\.a-z][\\.\\_a-z0-9]*", 
		rexpression = sprintf("^\\%s[^\\%s]+\\%s", escape.char, closing.escape.char, closing.escape.char ) 
	 )

	local.env <- new.env(parent=envir )
	current.token <- current.value <- NULL
	parsed.chars <- parsed.lines <- 0
	tokens <- token.values <- c( )
	tablespace <- list( ) 

	accept <- function(token, ignore.whitespace = TRUE, ignore.comments = TRUE ) {
		if (ignore.comments ) 
			while (accept("comment", ignore.whitespace, FALSE ) ) {}
		if (ignore.whitespace ) 
			accept("ws", FALSE, FALSE )
		if (token == "eof" ) 
			if (nchar(query ) == 0 ) {
				current.token <<- "eof"
				current.value <<- NA
				return(TRUE )
			} else
				return(FALSE )
		if ((res <- regexpr(tokenset[[token]], query, ignore.case = T ) ) > -1 ) {
			token.length <- attr(res, "match.length" )
			parsed.chars <<- parsed.chars + token.length
			current.token <<- token
			current.value <<- substr(query, 1, token.length )
			parsed.lines <<- parsed.lines + sum(gregexpr("\n", current.value )[[1]]>-1 ) 
			query <<- substr(query, 1 + token.length, nchar(query ) )
			tokens <<- c(tokens, current.token )
			token.values <<- c(token.values, current.value )
			return(TRUE )
		}
		return(FALSE )
	}

	expect <- function(tokens ) {
		for (token in tokens ) 
			if (accept(token ) ) return(TRUE )
		errmsg <- sprintf("Parse error after %s characters (line %s). ", 
			parsed.chars, parsed.lines+1 ) 
		errmsg <- paste(errmsg, sprintf("\n expected: %s, \n found: '%s'. ", 
			paste(sprintf("'%s'", tokens ), collapse=" or " ), 
			if (nchar(query) ) sprintf("%s...", substr(query, 1, 20 ) ) else "eof" ) ) 
		stop(errmsg, call. = FALSE )
	}

	expressions.to.values <- function(column.expressions, source.table ) {
		# helper function: evaluates a list of expressions in a data.frame
		resultset <- data.frame(lapply(column.expressions, function(column.expression ) 
			eval(parse(text=column.expression ), source.table ) ), 
			stringsAsFactors = FALSE )
		row.names(resultset ) <- seq(length.out=nrow(resultset ) ) 
		return(resultset ) 
	}

	aggregate.ranks <- function(column.expressions, source.table ) {
		# helper function: yields row-wide ranks after evaluating 
		# a list of expressions (of decreasing priority ) in a data.frame 
		column.valuesets <- expressions.to.values(column.expressions, source.table ) 
		ranks <- rep(0, nrow(source.table ) ) 
		for (column.valueset in column.valuesets ) 
			ranks <- (ranks+rank(column.valueset ) )*nrow(source.table )
		return(ranks )
	}

	ridentifier.or.expression <- function( ) {
		if (accept("ridentifier" ) ) 
			return(current.value )
		if (accept("rexpression" ) ) 
			return((current.value <<- gsub(sprintf("\\%s", escape.char ), "", 
				gsub(sprintf("\\%s", closing.escape.char ), "", current.value ) ) ) ) 
		expect(c("ridentifier", "rexpression" ) )
	}

	column <- function( ) {
		columns <- list( )
		column.name <- column.expression <- ridentifier.or.expression( )
		if (accept("as" ) ) {
			expect("ridentifier" )
			column.name <- current.value 
		}
		columns[[column.name]] <- column.expression # parse(text= )
		return(columns )
	}

	column.list <- function( ) {
		columns <- column( )
		while (accept("comma" ) )
			columns <- c(columns, column( ) )
		return(columns )
	}

	ridentifier.list <- function( ) {
		expect("ridentifier" )
		ridentifiers <- c(current.value )
		while (accept("comma" ) ) {
			expect("ridentifier" )
			ridentifiers <- c(ridentifiers, current.value )
		}
		return(ridentifiers )
	}

	single.source <- function( ) {
		resultset <- tablename <- NA
		if (accept("bropen" ) ) {
			resultset <- select.stmt( )
			expect("brclose" )
			# derived tables have to be named 
			expect("as" )
			tablename <- make.names(ridentifier.or.expression( ) ) 
		} else {
			ridentifier.or.expression( )
			tablename <- make.names(current.value )[[1]]
			resultset <- as.data.frame(eval(parse(text=current.value ), local.env ) ) 
			if (accept("as" ) )
				tablename <- make.names(ridentifier.or.expression( ) ) 
		}
		# print(paste("Found table named '", tablename, "'. ", sep="" ) ) #
		attr(resultset, "name" ) <- tablename
		return(resultset ) 
	}

	join.op <- function( ) {
		if (accept("comma" ) ) 
			return(TRUE ) 
		if (accept("crossjoin" ) ) 
			return(TRUE ) 
		if (accept("naturaljoin" ) ) 
			return(TRUE ) 
		if (accept("innerjoin" ) ) 
			return(TRUE ) 
		if (accept("leftjoin" ) ) 
			return(TRUE ) 
		return(FALSE ) 
	} 

	index.tablespace <- function(tablespace, index ) {
		# a helper function to apply an index to a list of data.frames 
		for (tablename in names(tablespace ) ) 
			tablespace[[tablename]] <- tablespace[[tablename]][index,]
		tablespace
	}

	evaluate.expression <- function(expression.string, tablespace, resultset ) {
		# helper function to evaluate an expression string 
		# within either a set of data.frames ('tablespace' ) 
		# and alternatively a single data.frame ('resultset' )
		evalq(evalq(eval(parse(text=expression.string ) ), 
			tablespace ), as.list(resultset ) ) 
	} 

	join.source <- function( ) {
		resultset <- single.source( ) 
		tablespace[[attr(resultset, "name" ) ]] <<- resultset
		while (join.op( ) ) {
			op <- current.token
			# print(sprintf("Attempting to perform a <%s> JOINing operation. ", op ) )
			second.resultset <- single.source( ) 
			
			# first build a cartesian product: 
			index.1 <- rep(seq(length.out=nrow(resultset ) ), nrow(second.resultset ) )
			index.2 <- rep(seq(length.out=nrow(second.resultset ) ), each=nrow(resultset ) )
			
			tablespace <<- index.tablespace(tablespace, index.1 ) 
			tablespace[[attr(second.resultset, "name" ) ]] <<- second.resultset[index.2,]
			
			column.names <- c(names(resultset ), names(second.resultset ) ) 
			resultset <- resultset[index.1,]
			second.resultset <- second.resultset[index.2,]
			if (op %in% c("comma", "crossjoin" ) ) {
				resultset <- data.frame(resultset, second.resultset, stringsAsFactors = FALSE ) 
				names(resultset ) <- column.names
			}
			if (op == "naturaljoin" ) {
				relevant.columns <- intersect(names(resultset ), names(second.resultset ) ) 
				conditionquery <- paste("resultset$", relevant.columns,
					"==second.resultset$", relevant.columns, sep="", collapse=" & " ) 
				row.matches <- eval(parse(text=conditionquery ) )
				resultset <- data.frame(resultset, second.resultset, stringsAsFactors = FALSE ) 
				names(resultset ) <- column.names
				resultset <- resultset[row.matches,unique(names(resultset ) )] 
				tablespace <<- index.tablespace(tablespace, row.matches ) 
			}
			if (op %in% c("innerjoin", "leftjoin" ) ) {
				row.matches <- c()
				expect(c("on","using" ) ) 
				if (current.token=="on" ) {
					expect("bropen" )
					condition <- ridentifier.or.expression( )
					expect("brclose" )
					row.matches <- as.logical(evaluate.expression(condition, tablespace, resultset ) )
				} else {
					expect("bropen" )
					identifiers <- ridentifier.list( )
					conditionquery <- paste("resultset$", identifiers,
						"==second.resultset$", identifiers, sep="", collapse=" & " ) 
					expect("brclose" )
					row.matches <- eval(parse(text=conditionquery ) )
				}
				if (op == "leftjoin" ) {
					left.matching.rows <- sapply(setdiff(index.1, index.1[row.matches]), 
						function(i) min(which(i==index.1))) 
					left.matches <- seq(length.out=length(index.1)) %in% left.matching.rows
					second.resultset[left.matches,] <- NA
					tablespace[[attr(second.resultset, "name" ) ]][left.matches,] <<- NA
					row.matches <- row.matches | left.matches 
				} 
				resultset <- data.frame(resultset, second.resultset, stringsAsFactors = FALSE ) 
				names(resultset ) <- column.names
				resultset <- resultset[row.matches,] 
				tablespace <<- index.tablespace(tablespace, row.matches ) 
			}
		}
		return(resultset )
	}

	select.core <- function( ) {
		if (!accept("select" ) ) 
			return(NA ) 
		distinct.switch <- accept("distinct")
		column.expressions <- groupby <- NULL 
		if (!accept("allcols" ) ) 
			column.expressions <- column.list( ) 
		expect("from" )
		result.table <- join.source( ) 
		if (accept("where" ) ) {
			row.matches <- as.logical(evaluate.expression(ridentifier.or.expression( ), 
				tablespace, result.table ) )
			result.table <- result.table[row.matches,,drop=FALSE]
			tablespace <<- index.tablespace(tablespace, row.matches ) 
		} 
		# aggregation: 
		if (accept("groupby" ) ) {
			groupby <- aggregate.ranks(column.list( ), result.table ) 
			if (is.null(column.expressions ) ) 
				stop("'SELECT *' is incompatible with 'GROUP BY'.", call. = FALSE )
			target.table <- i <- 0
			for (group in unique(groupby ) ) {
				result.subset <- result.table[group==groupby,,drop=FALSE]
				aggregated.subset <- sapply(column.expressions, simplify = FALSE, 
					function(column.expression ) {
						aggr <- eval(parse(text=column.expression ), result.subset )[[1]] 
						return(ifelse(is.factor(aggr ), as.character(aggr ), aggr ) ) 
					} )
				aggregated.subset <- data.frame(aggregated.subset, stringsAsFactors = FALSE )
				if (i ) {
					target.table[i+1,] <- aggregated.subset
				} else {
					first.row <- aggregated.subset
					target.table <- first.row
					# workaround to impede ORDER-stunting conversions 
					# mode(target.table ) <- "integer" 
					target.table[1,] <- first.row
				}
				i <- i+1 
			}
			result.table <- target.table
			if (accept("having" ) ) 
				result.table <- subset(result.table, 
					as.logical(eval(parse(text=ridentifier.or.expression( ) ), 
					result.table ) ) ) 
		} else if (!is.null(column.expressions ) ) {
			# result.table <- expressions.to.values(column.expressions, result.table ) 
			# print("current tablespace: "); print(tablespace)
			result.table <- data.frame(lapply(column.expressions, function(column.expression ) 
			 	evalq(evalq(eval(parse(text=column.expression ) ), tablespace ), as.list(result.table ) ) ), 
			 	stringsAsFactors = FALSE )
		} 
		if (distinct.switch ) 
			result.table <- unique(result.table)
		row.names(result.table ) <- seq(length.out=nrow(result.table ) )
		return(result.table )
	}

	compound.operator <- function( ) {
		if (accept("union" ) ) 
			return(function(t1,t2 ) { 
				return(unique(rbind(t1,t2 ) ) ) 
			} )
		if (accept("intersect" ) ) 
			return(function(t1,t2 ) { 
				return(rbind(unique(t1 ), unique(t2 ) )[duplicated(rbind(unique(t1 ), unique(t2 ) ) ),] ) 
			} )
		return(FALSE )
	}

	integer.number <- function( ) {
		expect("integer.number" ) 
		return(as.numeric(current.value ) ) 
	} 

	select.stmt <- function( ) {
		result.table <- select.core( )
		while (is.function((compounder <- compound.operator( ) ) ) ) {
			t2 <- select.core( )
			stopifnot(ncol(result.table ) == ncol(t2 ) ) 
			names(t2 ) <- names(result.table ) 
			result.table <- compounder(result.table, t2 ) 
		} 
		if (accept("orderby" ) ) {
			ranks <- aggregate.ranks(column.list( ), result.table ) 
			if (accept("desc" ) ) 
				ranks <- -ranks
			else 
				accept("asc" ) # optional default 
			result.table <- result.table[order(ranks ),,drop=FALSE]
		}
		if (accept("limit" ) ) {
			start.row <- 1 
			end.row <- integer.number( ) 
			if (accept("offset" ) ) {
				start.row <- 1 + integer.number( ) 
				end.row <- end.row + start.row - 1 
			} else if (accept("comma" ) ) {
				start.row <- end.row + 1 
				end.row <- start.row + integer.number( ) - 1
			}
			if (end.row < start.row ) 
				end.row <- start.row <- 0 
			result.table <- data.frame(result.table ) 
			cn <- colnames(result.table ) 
			end.row <- min(end.row, nrow(result.table ) ) 
			result.table <- result.table[start.row:end.row,,drop=FALSE]
			colnames(result.table ) <- cn
		}
		if (is.list(result.table ) ) 
			row.names(result.table ) <- seq(length.out=nrow(result.table ) )
		return(result.table )
	}

	sql.stmt <- function( ) {
		if (accept("create" ) ) {
			assign.temporary <- accept("temporary" ) || accept("temp" ) 
			target.env <- if (assign.temporary ) local.env else envir
			create.view <- accept("view" ) 
			if (!create.view ) 
				expect(c("view","table" ) )
			if (create.view ) {
				expect("ridentifier" )
				identifier <- current.value
				expect("as" ); expect("bropen" )
				token.length <- sum(nchar(sql.select(query, what.to.parse="select.stmt", 
					fetch.tokenlist = TRUE )$token.values ) )
				sql.syntax <- substr(query, 1, token.length )
				query <<- substr(query, 1 + token.length, nchar(query ) )
				tokens <<- c(tokens, "viewsyntax" )
				token.values <<- c(token.values, sql.syntax )
				expect("brclose" )
				view <- new("sql.view", sql.syntax )
				assign(identifier, view, envir=target.env ) 
				if (!assign.temporary )
					print(sprintf("Created view '%s'. ", identifier ) ) 
				return(view )
			} else {
				expect("ridentifier" )
				identifier <- current.value
				expect("as" ); expect("bropen" )
				resultset <- select.stmt( )
				expect("brclose" )
				assign(identifier, resultset, envir=target.env ) 
				if (!assign.temporary )
					print(sprintf("Wrote table '%s' with %s columns and %s rows. ", 
						identifier, ncol(resultset ), nrow(resultset ) ) )
				return(resultset )
			}
		}
		return(select.stmt( ) )
	}
	
	sql.stmt.sequence <- function( ) {
		while (accept("semicolon" ) ){}
		resultset <- NA
		tmp.resultset <- sql.stmt( )
		while (is.list(tmp.resultset ) | is(tmp.resultset, "sql.view" ) ) {
		    resultset <- tmp.resultset
		    while (accept("semicolon" ) ){}
		    tmp.resultset <- sql.stmt( )
		}
		expect(c("create","select","eof","semicolon" ) )
		return(resultset )
	}

	resultset <- do.call(what.to.parse, list( ) )
	if (fetch.tokenlist ) 
		return(data.frame(tokens=tokens, token.values=token.values, 
			stringsAsFactors=FALSE ) ) 
	else 
		return(resultset ) 
}

setClass("sql.view", representation( ), contains = "character" ) 
setMethod("as.data.frame", "sql.view", 
	function(x, row.names = NULL, optional = FALSE, ... ) 
		return(sql.select(slot(x, ".Data" ), what.to.parse="select.stmt", ... ) ) )
